home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / PSPPD100 / DBASE.PAS next >
Pascal/Delphi Source File  |  1992-09-18  |  27KB  |  1,258 lines

  1. {
  2.  
  3.                                                       ╔══════════════════╗
  4.                                                       ║    Pure Power    ║
  5.                                                       ║   Database Ctrl. ║
  6.                                                       ║    Rev.  1.00    ║
  7.                                                       ╚══════════════════╝
  8.  
  9. }
  10.  
  11. {$F-} {$O-} {$A+} {$G-} {$I-}
  12. {$V-} {$B-} {$X-} {$N+} {$E+}
  13.  
  14. {$I FINAL.PAS}
  15.  
  16. {$IFDEF FINAL}
  17.   {$R-} {$S-}
  18.   {$D-} {$L-}
  19. {$ENDIF}
  20.  
  21. Unit DBase;
  22.  
  23. Interface
  24.  
  25. Uses Dos,Strings,DBStack;
  26.  
  27. Const
  28.   TempFile      = '$$PPDB$$.$$$';
  29.   Signature     = 'PPDATABASE';
  30.  
  31.   CurVerHi      = 1;
  32.   CurVerLo      = 00;
  33.  
  34.   NameFlag      = 1;
  35.   InEXEFlag     = 2;
  36.  
  37.   DirFlag       = 1;
  38.  
  39.   C_None        = 0;
  40.   C_ARJ         = 1;
  41.   C_ZIP         = 2;
  42.   C_LHA         = 3;
  43.   C_ZOO         = 4;
  44.   C_Other       = 49;
  45.  
  46. Type
  47.   DBaseDirPtr   = ^DBaseDir;
  48.  
  49.   DBaseDir      = Record
  50.                     Name   :String[12];
  51.                     Number :Word;
  52.                     Offset :LongInt;
  53.                     Size   :Word;
  54.                     Attr   :Byte;
  55.                     Next   :DBaseDirPtr;
  56.                   End;
  57.  
  58.   DBaseMain     = Record
  59.                     Total  :Word;
  60.                     Root   :Pointer;
  61.                     Data   :DBaseDirPtr;
  62.                   End;
  63.  
  64.   DBaseFile     = Object
  65.  
  66.                     PrevDirs  :StackObject;
  67.  
  68.                     HaveNames,
  69.                     InEXE     :Boolean;
  70.  
  71.                     DataSize  :Word;
  72.                     Compress,
  73.                     DirEntry  :Byte;     {Length of each Dir entry in bytes}
  74.  
  75.                     FileName  :PathStr;
  76.                     FileStart,
  77.                     FileEnd   :LongInt;
  78.                     Dir       :DBaseMain;
  79.  
  80.                     VerHi,
  81.                     VerLo     :Byte;
  82.  
  83.                     Procedure Init;
  84.                     Procedure GotoDir           (Number:Word);
  85.                     Procedure DelDir            (Number:Word);
  86.                     Procedure AppendDir         (Var Data:DBaseDir);
  87.                     Procedure AdjustDirsAfter   (Offset,BySize:LongInt);
  88.                     Procedure AdjustStackAfter  (Offset,BySize:LongInt);
  89.                     Procedure DestroyDirs;
  90.  
  91.                     Function  FindEXESignature  (LookFrom:LongInt;Var EndPtr:LongInt):Word;
  92.                     Function  WriteHeader       :Word;
  93.                     Function  FindDir           (Var Data:DBaseDir):Word;
  94.                     Function  SetDirFlag        (Name:String;Number:Word;Flag:Boolean):Word;
  95.  
  96.                     Function  AddCompression    (FName:PathStr;Method:Byte):Word;
  97.                     Function  CreateDatabase    (FName:PathStr;NameOpt:Boolean):Word;
  98.                     Function  OpenDatabase      (FName:PathStr;DStart,DEnd:LongInt):Word;
  99.                     Function  CloseDatabase     :Word;
  100.                     Function  CrossIntoDatabase (Name:String;Number:Word):Word;
  101.                     Function  CrossOutOfDatabase:Word;
  102.  
  103.                     Function  BlockInsert       (Offset:LongInt;Data:Pointer;Size:Word):Word;
  104.                     Function  BlockOverwrite    (Offset:LongInt;Data:Pointer;Size:Word):Word;
  105.                     Function  BlockDelete       (Offset:LongInt;             Size:Word):Word;
  106.  
  107.                     Function  ReadDir           :Word;
  108.                     Function  WriteDir          :Word;
  109.  
  110.                     Function  NewData           (Name:String;Number:Word;Data:Pointer;Size:Word):Word;
  111.                     Function  ModData           (Name:String;Number:Word;Data:Pointer):Word;
  112.                     Function  GetData           (Name:String;Number:Word;Data:Pointer):Word;
  113.                     Function  DelData           (Name:String;Number:Word):Word;
  114.  
  115.                     Function  NewDataFile       (Name:String;Number:Word;FName:String):Word;
  116.                     Function  ModDataFile       (Name:String;Number:Word;FName:String):Word;
  117.                     Function  GetDataFile       (Name:String;Number:Word;FName:String):Word;
  118.  
  119.                     Function  ModEXE            (Offset:LongInt;Data:Pointer;Size:Word):Word;
  120.                     Function  GetEXE            (Offset:LongInt;Data:Pointer;Size:Word):Word;
  121.  
  122.                     Private
  123.  
  124.                     F         :File;
  125.  
  126.                   End;
  127.  
  128. Function  DatabaseErrorMsg(ErrorNumber:Word):String;
  129.  
  130.  
  131. Implementation
  132.  
  133. Procedure DBaseFile.Init;
  134. Begin
  135.   Dir.Total:=0;
  136.   Dir.Root :=NIL;
  137.   Dir.Data :=NIL;
  138.  
  139.   FileStart:=0;
  140.   FileEnd  :=0;
  141.   DirEntry :=0;
  142.   DataSize :=0;
  143.   FileName :='';
  144.  
  145.   VerHi    :=CurVerHi;
  146.   VerLo    :=CurVerLo;
  147.  
  148.   PrevDirs.Init;
  149. End;
  150.  
  151. Procedure DBaseFile.GotoDir(Number:Word);
  152.  
  153. Var
  154.   T:Word;
  155.  
  156. Begin
  157.   If Dir.Root=NIL Then Exit;
  158.   T:=1;
  159.   Dir.Data:=Dir.Root;
  160.   While (T<Number) And (Dir.Data^.Next<>NIL) do
  161.   Begin
  162.     Dir.Data:=Dir.Data^.Next;
  163.     Inc(T);
  164.   End;
  165. End;
  166.  
  167. Procedure DBaseFile.DelDir(Number:Word);
  168.  
  169. Var
  170.   P:DBaseDirPtr;
  171.   Q:Pointer;
  172.  
  173. Begin
  174.   Dec(Dir.Total);
  175.   If Number=1 Then
  176.   Begin
  177.     GotoDir(1);
  178.     P:=Dir.Data;
  179.     Dir.Root:=P^.Next;
  180.     Dir.Data:=P^.Next;
  181.     Dispose(P);
  182.   End
  183.   Else
  184.   Begin
  185.     GotoDir(Number);
  186.     Q:=Dir.Data^.Next;
  187.     P:=Dir.Data;
  188.     GotoDir(Number-1);
  189.     Dispose(P);
  190.     Dir.Data^.Next:=Q;
  191.   End;
  192. End;
  193.  
  194. Procedure DBaseFile.AppendDir(Var Data:DBaseDir);
  195.  
  196. Var
  197.   Q     :DBaseDirPtr;
  198.  
  199. Begin
  200.   New(Q);
  201.   Q^:=Data;
  202.   Q^.Next:=NIL;
  203.  
  204.   Inc(Dir.Total);
  205.   If Dir.Total=1 Then
  206.   Begin
  207.     Dir.Root:=Q;
  208.     Dir.Data:=Q;
  209.   End
  210.   Else
  211.   Begin
  212.     GotoDir(65535);
  213.     Dir.Data^.Next:=Q;
  214.   End;
  215. End;
  216.  
  217. Procedure DBaseFile.AdjustDirsAfter(Offset,BySize:LongInt);
  218. Begin
  219.   Dir.Data:=Dir.Root;
  220.   While Dir.Data<>NIL do
  221.   Begin
  222.     If Dir.Data^.Offset>=Offset Then
  223.       Inc(Dir.Data^.Offset,BySize);
  224.     Dir.Data:=Dir.Data^.Next;
  225.   End;
  226. End;
  227.  
  228. Procedure DBaseFile.AdjustStackAfter(Offset,BySize:LongInt);
  229.  
  230. Const
  231.   LastOffset:LongInt = 0;
  232.  
  233. Var
  234.   OldStack :StackObject;
  235.   DirInfo  :Data;
  236.  
  237. Begin
  238.   If Offset<>MaxLongInt Then  {Are we given an offset?}
  239.     LastOffset:=Offset        {Yes, so use it and remember it}
  240.   Else
  241.     Offset:=LastOffset;       {No, so use the last one we were given}
  242.  
  243.   OldStack.Init;
  244.   While Not PrevDirs.Empty do
  245.   Begin
  246.     PrevDirs.Pop(DirInfo);
  247.     If DirInfo.FileStart>=Offset Then Inc(DirInfo.FileStart,BySize);
  248.     If DirInfo.FileEnd  >=Offset Then Inc(DirInfo.FileEnd  ,BySize);
  249.     OldStack.Push(DirInfo);
  250.   End;
  251.  
  252.   While Not OldStack.Empty do
  253.   Begin
  254.     OldStack.Pop(DirInfo);
  255.     PrevDirs.Push(DirInfo);
  256.   End;
  257. End;
  258.  
  259. Procedure DBaseFile.DestroyDirs;
  260. Begin
  261.   Dir.Data:=Dir.Root;
  262.   While Dir.Data<>NIL do
  263.   Begin
  264.     Dir.Root:=Dir.Data^.Next;
  265.     Dispose(Dir.Data);
  266.     Dir.Data:=Dir.Root;
  267.   End;
  268.   Dir.Total:=0;
  269. End;
  270.  
  271. Function DBaseFile.FindEXESignature(LookFrom:LongInt;Var EndPtr:LongInt):Word;
  272.  
  273. Const
  274.   MaxAm = 255;
  275.  
  276. Var
  277.   CheckSig:String;
  278.   NewSig  :String[15];
  279.   Found   :LongInt;
  280.   Amount  :LongInt;
  281.   ThisTime:LongInt;
  282.  
  283. Begin
  284.   NewSig:=Signature+'EX';
  285.   Found :=0;
  286.   Amount:=FileSize(F)-LookFrom;
  287.   PadVar('',CheckSig,255);
  288.   NewSig:=NewSig+'E';
  289.   Seek(F,LookFrom);
  290.  
  291.   While (Amount<>0) And (Found=0) do
  292.   Begin
  293.     If Amount>MaxAm Then
  294.       ThisTime:=MaxAm
  295.     Else
  296.       ThisTime:=Amount;
  297.  
  298.     BlockRead(F,CheckSig[1],ThisTime);
  299.     If Pos(NewSig,CheckSig)>0 Then
  300.       Found:=FilePos(F)-ThisTime+Pos(NewSig,CheckSig)+Length(NewSig)-4
  301.     Else
  302.     Begin
  303.       If EOF(F) Then
  304.         Amount:=0
  305.       Else
  306.       Begin
  307.         Dec(Amount,ThisTime-18);
  308.         Seek(F,FilePos(F)-18);
  309.       End;
  310.     End;
  311.   End;
  312.   EndPtr:=Found;
  313.   FindEXESignature:=IOResult;
  314. End;
  315.  
  316. Function DBaseFile.WriteHeader:Word;
  317.  
  318. Var
  319.   Hdr :String;
  320.  
  321. Begin
  322.   If InEXE Then
  323.     Move(DataSize,Hdr[1],2)
  324.   Else
  325.     Move(Dir.Total,Hdr[1],2);
  326.  
  327.   Hdr[3]:=#0;
  328.   Hdr[4]:=Chr(Compress);
  329.  
  330.   Hdr[5]:=Chr(0);
  331.   If InEXE Then
  332.     Hdr[5]:=Chr(Ord(Hdr[4]) Or InEXEFlag);
  333.   If HaveNames Then
  334.     Hdr[5]:=Chr(Ord(Hdr[4]) Or NameFlag);
  335.  
  336.   Hdr[0]:=#5;
  337.   Hdr:=Hdr+Chr(CurVerHi)+Chr(CurVerLo)+Signature;
  338.  
  339.   BlockWrite(F,Hdr[1],17);
  340.   WriteHeader:=IOResult;
  341. End;
  342.  
  343. Function DBaseFile.SetDirFlag(Name:String;Number:Word;Flag:Boolean):Word;
  344.  
  345. Var
  346.   WhichOne :Word;
  347.   DirData  :DBaseDir;
  348.  
  349. Begin
  350.   DirData.Name   :=Name;
  351.   DirData.Number :=Number;
  352.   WhichOne:=FindDir(DirData);
  353.   If WhichOne<>0 Then
  354.   Begin
  355.     If Flag Then
  356.       Dir.Data^.Attr:=Dir.Data^.Attr Or DirFlag
  357.     Else
  358.       Dir.Data^.Attr:=Dir.Data^.Attr And (Not DirFlag);
  359.     SetDirFlag:=WriteDir;
  360.   End
  361.   Else
  362.     SetDirFlag:=603;
  363. End;
  364.  
  365. Function DBaseFile.AddCompression(FName:PathStr;Method:Byte):Word;
  366.  
  367. Label
  368.   EndProc;
  369.  
  370. Var
  371.   ErrorCode:Word;
  372.  
  373. Begin
  374.   Assign(F,FName);
  375.   Reset(F,1);
  376.   ErrorCode:=IOResult;
  377.   If ErrorCode>0 Then Goto EndProc;
  378.  
  379.   InEXE      :=False;
  380.   HaveNames  :=False;
  381.   Dir.Total  :=0;
  382.   Compress   :=Method;
  383.  
  384.   Seek(F,FileSize(F));
  385.   ErrorCode:=WriteHeader;
  386.   Close(F);
  387.  
  388. EndProc:
  389.  
  390.   AddCompression:=ErrorCode;
  391. End;
  392.  
  393. Function DBaseFile.CreateDatabase(FName:PathStr;NameOpt:Boolean):Word;
  394.      {No Database may be open.  The Database is NOT opened.}
  395. Var
  396.   ErrorCode :Word;
  397.  
  398. Begin
  399.   Init;
  400.  
  401.   InEXE        :=False;
  402.   HaveNames    :=NameOpt;
  403.   FileName     :=FName;
  404.   Compress     :=0;
  405.  
  406.   Assign(F,FName);
  407.   Rewrite(F,1);
  408.   ErrorCode:=IOResult;
  409.   If ErrorCode=0 Then ErrorCode:=WriteHeader;
  410.   Close(F);
  411.  
  412.   Init;
  413.   CreateDatabase:=ErrorCode;
  414. End;
  415.  
  416. Function DBaseFile.FindDir(Var Data:DBaseDir):Word;
  417.          {Returns the position number in the list, not the file number}
  418. Var
  419.   Found:Boolean;
  420.   Count:Word;
  421.  
  422. Begin
  423.   FindDir:=0;
  424.   If Dir.Total=0 Then Exit;
  425.   Found:=False;
  426.  
  427.   If HaveNames Then
  428.   Begin
  429.     Count:=0;
  430.     Dir.Data:=Dir.Root;
  431.     While (Dir.Data<>NIL) And Not Found do
  432.     Begin
  433.       Inc(Count);
  434.       If (Data.Name=Dir.Data^.Name) And (Data.Number=Dir.Data^.Number) Then
  435.         Found:=True
  436.       Else
  437.         Dir.Data:=Dir.Data^.Next;
  438.     End;
  439.  
  440.     If Not Found Then
  441.     Begin
  442.       Count:=0;
  443.       Dir.Data:=Dir.Root;
  444.       While (Dir.Data<>NIL) And Not Found do
  445.       Begin
  446.         Inc(Count);
  447.         If (Data.Name=Dir.Data^.Name) Then
  448.           Found:=True
  449.         Else
  450.           Dir.Data:=Dir.Data^.Next;
  451.       End;
  452.     End;
  453.  
  454.   End;
  455.  
  456.   If Not Found Then
  457.   Begin
  458.     Count:=0;
  459.     Dir.Data:=Dir.Root;
  460.     While (Dir.Data<>NIL) And Not Found do
  461.     Begin
  462.       Inc(Count);
  463.       If (Data.Number=Dir.Data^.Number) Then
  464.         Found:=True
  465.       Else
  466.         Dir.Data:=Dir.Data^.Next;
  467.     End;
  468.   End;
  469.  
  470.   If Found Then
  471.   Begin
  472.     Data.Offset:=Dir.Data^.Offset;
  473.     Data.Size  :=Dir.Data^.Size;
  474.     Data.Attr  :=Dir.Data^.Attr;
  475.     FindDir    :=Count;
  476.   End;
  477. End;
  478.  
  479. Function DBaseFile.OpenDatabase(FName:PathStr;DStart,DEnd:LongInt):Word;
  480.  
  481. Label
  482.   EndProc,
  483.   EndProcAndClose;
  484.  
  485. Var
  486.   ErrorCode :Word;
  487.   CheckSig  :String[10];
  488.  
  489. Begin
  490.   ErrorCode:=0;
  491.  
  492.   If FName<>'' Then
  493.   Begin
  494.     Assign(F,FName);
  495.     Reset(F,1);
  496.     ErrorCode:=IOResult;
  497.     If ErrorCode<>0 Then Goto EndProc;
  498.     FileName:=FName;
  499.   End;
  500.  
  501.   If (DStart=DEnd) Then     { ** For InEXE Only ** }
  502.   Begin
  503.     ErrorCode:=FindEXESignature(DEnd,FileEnd);
  504.   End
  505.   Else
  506.   Begin
  507.     FileStart:=DStart;
  508.     If DEnd=MaxLongInt Then
  509.       FileEnd:=FileSize(F)
  510.     Else
  511.       FileEnd  :=DEnd;
  512.   End;
  513.  
  514.   If ErrorCode<>0 Then Goto EndProcAndClose;
  515.  
  516.   Seek(F,FileEnd-10);
  517.   BlockRead(F,CheckSig[1],10);
  518.   CheckSig[0]:=#10;
  519.   ErrorCode:=IOResult;
  520.   If (ErrorCode<>0) Or (CheckSig<>Signature) Then
  521.   Begin
  522.     ErrorCode:=701;     {Not a PPD File}
  523.     Goto EndProcAndClose;
  524.   End;
  525.  
  526.   Seek(F,FileEnd-17);
  527.   BlockRead(F,CheckSig[1],7);
  528.   ErrorCode:=IOResult;
  529.   If ErrorCode<>0 Then
  530.   Begin
  531.     ErrorCode:=702;     {Not a PPD File}
  532.     Goto EndProcAndClose;
  533.   End;
  534.  
  535.   Compress:=Ord(CheckSig[4]);
  536.  
  537.   If (Ord(CheckSig[5]) And InEXEFlag) = 0 Then
  538.     InEXE:=False
  539.   Else
  540.     InEXE:=True;
  541.  
  542.   If (Ord(CheckSig[5]) And NameFlag) = 0 Then
  543.     HaveNames:=False
  544.   Else
  545.     HaveNames:=True;
  546.  
  547.   If InEXE Then
  548.     Move(CheckSig[1],DataSize,2)
  549.   Else
  550.   Begin
  551.     If HaveNames Then
  552.       DirEntry:=12+2+4+2+1
  553.     Else
  554.       DirEntry:=2+4+2+1;
  555.   End;
  556.  
  557.   VerHi:=Ord(CheckSig[6]);
  558.   VerLo:=Ord(CheckSig[7]);
  559.  
  560.   If VerHi>CurVerHi Then
  561.     ErrorCode:=602
  562.   Else
  563.     If VerLo>CurVerLo Then
  564.       ErrorCode:=601;
  565.  
  566.   If Compress<>C_None Then
  567.     ErrorCode:=650+Compress;
  568.  
  569.   Goto EndProc;
  570.  
  571. EndProcAndClose:
  572.  
  573.   Close(F);
  574.  
  575. EndProc:
  576.  
  577.   If Not InEXE And (ErrorCode=0) Then ErrorCode:=ReadDir;
  578.   OpenDatabase:=ErrorCode;
  579. End;
  580.  
  581. Function DBaseFile.CloseDatabase:Word;
  582. Begin
  583.   PrevDirs.Destroy;
  584.   Init;
  585.   Close(F);
  586.   CloseDatabase:=IOResult;
  587. End;
  588.  
  589. Function DBaseFile.CrossIntoDatabase(Name:String;Number:Word):Word;
  590.                         {Never Add or Delete From a Directory Database}
  591. Var
  592.   WhichOne :Word;
  593.   DirData  :DBaseDir;
  594.   OldDir   :Data;
  595.  
  596. Begin
  597.   DirData.Name:=Name;
  598.   DirData.Number:=Number;
  599.   WhichOne:=FindDir(DirData);
  600.  
  601.   If WhichOne=0 Then
  602.     CrossIntoDatabase:=603
  603.   Else
  604.   Begin
  605.     DestroyDirs;
  606.     If PrevDirs.Full Then
  607.       CrossIntoDatabase:=604
  608.     Else
  609.     Begin
  610.       OldDir.FileStart:=FileStart;
  611.       OldDir.FileEnd  :=FileEnd;
  612.       PrevDirs.Push(OldDir);
  613.       CrossIntoDatabase:=OpenDatabase('',DirData.Offset,DirData.Offset+DirData.Size);
  614.     End;
  615.   End;
  616. End;
  617.  
  618. Function DBaseFile.CrossOutOfDatabase:Word;
  619.  
  620. Var
  621.   OldDir :Data;
  622.  
  623. Begin
  624.   If PrevDirs.Empty Then
  625.     CrossOutOfDatabase:=605
  626.   Else
  627.   Begin
  628.     DestroyDirs;
  629.     PrevDirs.Pop(OldDir);
  630.     CrossOutOfDatabase:=OpenDatabase('',OldDir.FileStart,OldDir.FileEnd);
  631.   End;  
  632. End;
  633.  
  634. Function DBaseFile.BlockInsert(Offset:LongInt;Data:Pointer;Size:Word):Word;
  635.  
  636. Label
  637.   EndProc,
  638.   EndProcAndClose;
  639.  
  640. Var
  641.   ErrorCode :Word;
  642.   G         :File;
  643.   P         :Pointer;
  644.   AmountLeft:LongInt;
  645.   CopyAmnt,
  646.   BlockSize :Word;
  647.  
  648. Begin
  649.   ErrorCode:=0;
  650.  
  651.   Seek(F,0);
  652.   ErrorCode:=IOResult;
  653.   If ErrorCode<>0 Then Goto EndProc;
  654.   Assign(G,TempFile);
  655.   Rewrite(G,1);
  656.   ErrorCode:=IOResult;
  657.   If ErrorCode<>0 Then Goto EndProc;
  658.  
  659.   Seek(G,FileSize(F)+Size-1);
  660.   BlockWrite(G,G,1);            {Make the File the Correct Size}
  661.   ErrorCode:=IOResult;
  662.   If ErrorCode>0 Then Goto EndProcAndClose;
  663.  
  664.   If MaxAvail>=64512 Then
  665.     BlockSize:=64512
  666.   Else
  667.     BlockSize:=MaxAvail;
  668.  
  669.   GetMem(P,BlockSize);
  670.  
  671.   Seek(F,0);
  672.   Seek(G,0);
  673.  
  674.   AmountLeft:=Offset;
  675.  
  676.   While (AmountLeft<>0) And (ErrorCode=0) do
  677.   Begin
  678.     If AmountLeft<BlockSize Then
  679.       CopyAmnt:=AmountLeft
  680.     Else
  681.       CopyAmnt:=BlockSize;
  682.     BlockRead (F,P^,CopyAmnt);
  683.     BlockWrite(G,P^,CopyAmnt);
  684.     ErrorCode:=IOResult;
  685.     Dec(AmountLeft,CopyAmnt);
  686.   End;
  687.  
  688.   BlockWrite(G,Data^,Size);
  689.   If ErrorCode=0 Then ErrorCode:=IOResult;
  690.  
  691.   AmountLeft:=FileSize(F)-Offset;
  692.  
  693.   While (AmountLeft<>0) And (ErrorCode=0) do
  694.   Begin
  695.     If AmountLeft<BlockSize Then
  696.       CopyAmnt:=AmountLeft
  697.     Else
  698.       CopyAmnt:=BlockSize;
  699.     BlockRead (F,P^,CopyAmnt);
  700.     BlockWrite(G,P^,CopyAmnt);
  701.     ErrorCode:=IOResult;
  702.     Dec(AmountLeft,CopyAmnt);
  703.   End;
  704.  
  705.   FreeMem(P,BlockSize);
  706.  
  707.   If ErrorCode<>0 Then Goto EndProcAndClose;
  708.  
  709.   Close(F);
  710.   Close(G);
  711.   Assign(F,FileName);
  712.   Erase(F);
  713.   Assign(G,TempFile);
  714.   Rename(G,FileName);
  715.   Assign(F,FileName);
  716.   Reset(F,1);
  717.   ErrorCode:=IOResult;
  718.  
  719.   Goto EndProc;
  720.  
  721. EndProcAndClose:
  722.  
  723.   Close(G);
  724.   Assign(G,TempFile);
  725.   Erase(G);
  726.  
  727. EndProc:
  728.  
  729.   BlockInsert:=ErrorCode;
  730. End;
  731.  
  732. Function DBaseFile.BlockOverwrite(Offset:LongInt;Data:Pointer;Size:Word):Word;
  733.          {Uses ABSOLUTE File Adress}
  734.  
  735. Label
  736.   EndProc;
  737.  
  738. Var
  739.   ErrorCode :Word;
  740.  
  741. Begin
  742.   ErrorCode:=0;
  743.  
  744.   Seek(F,Offset);
  745.   ErrorCode:=IOResult;
  746.   If ErrorCode<>0 Then Goto EndProc;
  747.  
  748.   BlockWrite(F,Data^,Size);
  749.   ErrorCode:=IOResult;
  750.  
  751. EndProc:
  752.  
  753.   BlockOverwrite:=ErrorCode;
  754. End;
  755.  
  756. Function DBaseFile.BlockDelete(Offset:LongInt;Size:Word):Word;
  757.  
  758. Label
  759.   EndProc,
  760.   EndProcAndClose;
  761.  
  762. Var
  763.   ErrorCode :Word;
  764.   G         :File;
  765.   P         :Pointer;
  766.   AmountLeft:LongInt;
  767.   CopyAmnt,
  768.   BlockSize :Word;
  769.  
  770. Begin
  771.   ErrorCode:=0;
  772.  
  773.   Seek(F,0);
  774.   ErrorCode:=IOResult;
  775.   If ErrorCode<>0 Then Goto EndProc;
  776.   Assign(G,TempFile);
  777.   Rewrite(G,1);
  778.   ErrorCode:=IOResult;
  779.   If ErrorCode<>0 Then Goto EndProc;
  780.  
  781.   Seek(G,FileSize(F)-Size-1);
  782.   BlockWrite(G,G,1);            {Make the File the Correct Size}
  783.   ErrorCode:=IOResult;
  784.   If ErrorCode>0 Then Goto EndProcAndClose;
  785.  
  786.   If MaxAvail>=64512 Then
  787.     BlockSize:=64512
  788.   Else
  789.     BlockSize:=MaxAvail;
  790.  
  791.   GetMem(P,BlockSize);
  792.  
  793.   Seek(F,0);
  794.   Seek(G,0);
  795.  
  796.   AmountLeft:=Offset;
  797.  
  798.   While (AmountLeft<>0) And (ErrorCode=0) do
  799.   Begin
  800.     If AmountLeft<BlockSize Then
  801.       CopyAmnt:=AmountLeft
  802.     Else
  803.       CopyAmnt:=BlockSize;
  804.     BlockRead (F,P^,CopyAmnt);
  805.     BlockWrite(G,P^,CopyAmnt);
  806.     ErrorCode:=IOResult;
  807.     Dec(AmountLeft,CopyAmnt);
  808.   End;
  809.  
  810.   Seek(F,FilePos(F)+Size);
  811.  
  812.   AmountLeft:=FileSize(F)-Offset-Size;
  813.  
  814.   While (AmountLeft<>0) And (ErrorCode=0) do
  815.   Begin
  816.     If AmountLeft<BlockSize Then
  817.       CopyAmnt:=AmountLeft
  818.     Else
  819.       CopyAmnt:=BlockSize;
  820.     BlockRead (F,P^,CopyAmnt);
  821.     BlockWrite(G,P^,CopyAmnt);
  822.     ErrorCode:=IOResult;
  823.     Dec(AmountLeft,CopyAmnt);
  824.   End;
  825.  
  826.   FreeMem(P,BlockSize);
  827.  
  828.   If ErrorCode<>0 Then Goto EndProcAndClose;
  829.  
  830.   Close(F);
  831.   Close(G);
  832.   Assign(F,FileName);
  833.   Erase(F);
  834.   Assign(G,TempFile);
  835.   Rename(G,FileName);
  836.   Assign(F,FileName);
  837.   Reset(F,1);
  838.   ErrorCode:=IOResult;
  839.  
  840.   Goto EndProc;
  841.  
  842. EndProcAndClose:
  843.  
  844.   Close(G);
  845.   Assign(G,TempFile);
  846.   Erase(G);
  847.  
  848. EndProc:
  849.  
  850.   BlockDelete:=ErrorCode;
  851. End;
  852.  
  853. Function DBaseFile.ReadDir:Word;
  854.  
  855. Var
  856.   X,
  857.   NewTotal :Word;
  858.   Data     :DBaseDir;
  859.  
  860. Begin
  861.   DestroyDirs;
  862.   Seek(F,FileEnd-17);
  863.   BlockRead(F,NewTotal,2);
  864.  
  865.   Seek(F,FileEnd-17-DirEntry*NewTotal);
  866.  
  867.   For X:=1 to NewTotal do
  868.   Begin
  869.     If HaveNames Then
  870.     Begin
  871.       BlockRead(F,Data.Name[1],12);
  872.       Data.Name[0]:=#12;
  873.       UnPadVar(Data.Name,Data.Name);
  874.     End
  875.     Else
  876.       Data.Name:='';
  877.  
  878.     BlockRead(F,Data.Number,9);
  879.     AppendDir(Data);
  880.   End;
  881.  
  882.   ReadDir:=IOResult;
  883. End;
  884.  
  885. Function DBaseFile.WriteDir:Word;
  886.  
  887. Var
  888.   NewName    :String[12];
  889.   ErrorCode,
  890.   OldTotal   :Word;
  891.  
  892. Begin
  893.   Seek(F,FileEnd-17);
  894.   BlockRead(F,OldTotal,2);
  895.   ErrorCode:=IOResult;
  896.   If ErrorCode=0 Then
  897.   Begin
  898.     If OldTotal<Dir.Total Then
  899.       ErrorCode:=BlockInsert(FileEnd-17,Ptr(0,0),(Dir.Total-OldTotal)*DirEntry)
  900.                                     {Insert any old data to make up file size}
  901.     Else
  902.       ErrorCode:=BlockDelete(FileEnd-17-(OldTotal-Dir.Total)*DirEntry,
  903.                                         (OldTotal-Dir.Total)*DirEntry);
  904.     Seek(F,FileEnd-17-DirEntry*OldTotal);
  905.     ErrorCode:=IOResult;
  906.   End;
  907.  
  908.   If ErrorCode=0 Then
  909.   Begin
  910.  
  911.     Dir.Data:=Dir.Root;
  912.     While (Dir.Data<>NIL) And (ErrorCode=0) do
  913.     Begin
  914.       If HaveNames Then
  915.       Begin
  916.         FormatVar(Dir.Data^.Name,NewName,12,LeftText);
  917.         BlockWrite(F,NewName[1],12);
  918.       End;
  919.       BlockWrite(F,Dir.Data^.Number,9);
  920.       Dir.Data:=Dir.Data^.Next;
  921.     End;
  922.     If ErrorCode=0 Then ErrorCode:=WriteHeader;
  923.     Inc(FileEnd,(LongInt(Dir.Total)-OldTotal)*DirEntry);
  924.     AdjustStackAfter(MaxLongInt,(LongInt(Dir.Total)-OldTotal)*DirEntry);
  925.   End;
  926.  
  927.   WriteDir:=ErrorCode;
  928. End;
  929.  
  930. Function DBaseFile.NewData(Name:String;Number:Word;Data:Pointer;Size:Word):Word;
  931.  
  932. Var
  933.   ErrorCode:Word;
  934.   DirData  :DBaseDir;
  935.  
  936. Begin
  937.   DirData.Name  :=Name;
  938.   DirData.Number:=Number;
  939.   DirData.Offset:=FileEnd-17-DirEntry*(Dir.Total);
  940.   DirData.Size  :=Size;
  941.   DirData.Attr  :=0;
  942.   AppendDir(DirData);
  943.  
  944.   ErrorCode:=BlockInsert(FileStart+DirData.Offset,Data,Size);
  945.   If ErrorCode=0 Then
  946.   Begin
  947.     Inc(FileEnd,Size);
  948.     AdjustStackAfter(FileStart+DirData.Offset,Size);
  949.     ErrorCode:=WriteDir;
  950.   End;
  951.  
  952.   NewData:=ErrorCode;
  953. End;
  954.  
  955. Function DBaseFile.ModData(Name:String;Number:Word;Data:Pointer):Word;
  956.  
  957. Var
  958.   WhichOne,
  959.   ErrorCode:Word;
  960.   DirData  :DBaseDir;
  961.  
  962. Begin
  963.   ErrorCode:=0;
  964.   DirData.Name  :=Name;
  965.   DirData.Number:=Number;
  966.   WhichOne:=FindDir(DirData);
  967.  
  968.   If WhichOne=0 Then ErrorCode:=603;
  969.  
  970.   If ErrorCode=0 Then
  971.     ErrorCode:=BlockOverwrite(FileStart+DirData.Offset,Data,DirData.Size);
  972.  
  973.   ModData:=ErrorCode;
  974. End;
  975.  
  976. Function DBaseFile.GetData(Name:String;Number:Word;Data:Pointer):Word;
  977.  
  978. Var
  979.   WhichOne,
  980.   ErrorCode   :Word;
  981.   DirData     :DBaseDir;
  982.  
  983. Begin
  984.   ErrorCode:=0;
  985.   DirData.Name  :=Name;
  986.   DirData.Number:=Number;
  987.   WhichOne:=FindDir(DirData);
  988.  
  989.   If WhichOne=0 Then ErrorCode:=603;
  990.  
  991.   If ErrorCode=0 Then
  992.   Begin
  993.     Seek(F,DirData.Offset);
  994.     BlockRead(F,Data^,DirData.Size);
  995.     ErrorCode:=IOResult;
  996.   End;
  997.  
  998.   GetData:=ErrorCode;
  999. End;
  1000.  
  1001. Function DBaseFile.DelData(Name:String;Number:Word):Word;
  1002.  
  1003. Var
  1004.   WhichOne,
  1005.   ErrorCode   :Word;
  1006.   DirData     :DBaseDir;
  1007.  
  1008. Begin
  1009.   ErrorCode:=0;
  1010.   DirData.Name  :=Name;
  1011.   DirData.Number:=Number;
  1012.   WhichOne:=FindDir(DirData);
  1013.  
  1014.   If WhichOne=0 Then ErrorCode:=603;
  1015.  
  1016.   If ErrorCode=0 Then
  1017.   Begin
  1018.     ErrorCode:=BlockDelete(FileStart+DirData.Offset,DirData.Size);
  1019.     DelDir(WhichOne);
  1020.   End;
  1021.  
  1022.   If ErrorCode=0 Then
  1023.   Begin
  1024.     AdjustDirsAfter(DirData.Offset,-DirData.Size);      {Don't add FileStart}
  1025.     Dec(FileEnd,DirData.Size);
  1026.     AdjustStackAfter(FileStart+DirData.Offset,-DirData.Size);
  1027.     ErrorCode:=WriteDir;
  1028.   End;
  1029.  
  1030.   DelData:=ErrorCode;
  1031. End;
  1032.  
  1033. Function DBaseFile.NewDataFile(Name:String;Number:Word;FName:String):Word;
  1034.  
  1035. Label
  1036.   EndProc,
  1037.   EndProcAndClose;
  1038.  
  1039. Var
  1040.   G        :File;
  1041.   ErrorCode:Word;
  1042.   Data     :Pointer;
  1043.   Size     :Word;
  1044.  
  1045. Begin
  1046.   Assign(G,FName);
  1047.   Reset(G,1);
  1048.   ErrorCode:=IOResult;
  1049.   If ErrorCode<>0 Then Goto EndProc;
  1050.  
  1051.   Size:=FileSize(G);
  1052.   If (Size>65500) Then
  1053.   Begin
  1054.     ErrorCode:=703;
  1055.     Goto EndProcAndClose;
  1056.   End;
  1057.  
  1058.   If (MaxAvail<5192) Or (MaxAvail-5192<Size) Then
  1059.   Begin
  1060.     ErrorCode:=203;
  1061.     Goto EndProcAndClose;
  1062.   End;
  1063.  
  1064.   GetMem(Data,Size);
  1065.   BlockRead(G,Data^,Size);
  1066.  
  1067.   ErrorCode:=NewData(Name,Number,Data,Size);
  1068.  
  1069.   FreeMem(Data,Size);
  1070.  
  1071. EndProcAndClose:
  1072.  
  1073.   Close(G);
  1074.  
  1075. EndProc:
  1076.  
  1077.   NewDataFile:=ErrorCode;
  1078. End;
  1079.  
  1080. Function DBaseFile.ModDataFile(Name:String;Number:Word;FName:String):Word;
  1081.  
  1082. Label
  1083.   EndProc,
  1084.   EndProcAndClose;
  1085.  
  1086. Var
  1087.   G        :File;
  1088.   WhichOne,
  1089.   ErrorCode:Word;
  1090.   Data     :Pointer;
  1091.   DirData  :DBaseDir;
  1092.   Size     :Word;
  1093.  
  1094. Begin
  1095.   ErrorCode:=0;
  1096.   DirData.Name  :=Name;
  1097.   DirData.Number:=Number;
  1098.   WhichOne:=FindDir(DirData);
  1099.   If WhichOne=0 Then
  1100.   Begin
  1101.     ErrorCode:=603;
  1102.     Goto EndProc;
  1103.   End;
  1104.  
  1105.   Assign(G,FName);
  1106.   Reset(G,1);
  1107.   ErrorCode:=IOResult;
  1108.   If ErrorCode<>0 Then Goto EndProc;
  1109.  
  1110.   Size:=FileSize(G);
  1111.   If (Size>65500) Then
  1112.   Begin
  1113.     ErrorCode:=703;
  1114.     Goto EndProcAndClose;
  1115.   End;
  1116.  
  1117.   If (Size<>DirData.Size) Then
  1118.   Begin
  1119.     ErrorCode:=606;
  1120.     Goto EndProcAndClose;
  1121.   End;
  1122.  
  1123.   If (MaxAvail<5192) Or (MaxAvail-5192<Size) Then
  1124.   Begin
  1125.     ErrorCode:=203;
  1126.     Goto EndProcAndClose;
  1127.   End;
  1128.  
  1129.   GetMem(Data,Size);
  1130.   BlockRead(G,Data^,Size);
  1131.  
  1132.   ErrorCode:=ModData(Name,Number,Data);
  1133.  
  1134.   FreeMem(Data,Size);
  1135.  
  1136. EndProcAndClose:
  1137.  
  1138.   Close(G);
  1139.  
  1140. EndProc:
  1141.  
  1142.   ModDataFile:=ErrorCode;
  1143. End;
  1144.  
  1145. Function DBaseFile.GetDataFile(Name:String;Number:Word;FName:String):Word;
  1146.  
  1147. Label
  1148.   EndProc,
  1149.   EndProcAndFree;
  1150.  
  1151. Var
  1152.   G           :File;
  1153.   DirData     :DBaseDir;
  1154.   Data        :Pointer;
  1155.   WhichOne,
  1156.   ErrorCode   :Word;
  1157.  
  1158. Begin
  1159.   ErrorCode:=0;
  1160.   DirData.Name  :=Name;
  1161.   DirData.Number:=Number;
  1162.   WhichOne:=FindDir(DirData);
  1163.   If WhichOne=0 Then
  1164.   Begin
  1165.     ErrorCode:=603;
  1166.     Goto EndProc;
  1167.   End;
  1168.  
  1169.   If (DirData.Size>65500) Then
  1170.   Begin
  1171.     ErrorCode:=703;
  1172.     Goto EndProc;
  1173.   End;
  1174.  
  1175.   If (MaxAvail<5192) Or (MaxAvail-5192<DirData.Size) Then
  1176.   Begin
  1177.     ErrorCode:=203;
  1178.     Goto EndProc;
  1179.   End;
  1180.  
  1181.   GetMem(Data,DirData.Size);
  1182.   ErrorCode:=GetData(Name,Number,Data);
  1183.  
  1184.   If ErrorCode=0 Then
  1185.   Begin
  1186.     Assign(G,FName);
  1187.     Rewrite(G,1);
  1188.     ErrorCode:=IOResult;
  1189.     If ErrorCode>0 Then Goto EndProcAndFree;
  1190.     BlockWrite(G,Data^,DirData.Size);
  1191.     Close(G);
  1192.     ErrorCode:=IOResult;
  1193.   End;
  1194.  
  1195. EndProcAndFree:
  1196.  
  1197.   FreeMem(Data,DirData.Size);
  1198.  
  1199. EndProc:
  1200.  
  1201.   GetDataFile:=ErrorCode;
  1202. End;
  1203.  
  1204. Function DBaseFile.ModEXE(Offset:LongInt;Data:Pointer;Size:Word):Word;
  1205. Begin
  1206.   Seek(F,FileEnd-17-DataSize+Offset);
  1207.   BlockWrite(F,Data^,Size);
  1208.   ModEXE:=IOResult;
  1209. End;
  1210.  
  1211. Function DBaseFile.GetEXE(Offset:LongInt;Data:Pointer;Size:Word):Word;
  1212. Begin
  1213.   Seek(F,FileEnd-17-DataSize+Offset);
  1214.   BlockRead(F,Data^,Size);
  1215.   GetEXE:=IOResult;
  1216. End;
  1217.  
  1218. Function DatabaseErrorMsg(ErrorNumber:Word):String;
  1219.  
  1220. Var
  1221.   Temp:String;
  1222.  
  1223. Begin
  1224.   If (ErrorNumber>650) And (ErrorNumber<700) Then
  1225.     Str(ErrorNumber-650,Temp)
  1226.   Else
  1227.     Str(ErrorNumber,Temp);
  1228.   Temp:=' '+Temp;
  1229.  
  1230.   Case ErrorNumber Of
  1231.     0     :DatabaseErrorMsg:='No Error';
  1232.     1..500:DatabaseErrorMsg:='Runtime Error'+Temp;
  1233.     601   :DatabaseErrorMsg:='Low-Version-Number Too High';
  1234.     602   :DatabaseErrorMsg:='High-Version-Number Too High';
  1235.     603   :DatabaseErrorMsg:='Item Requested Not Found in Database';
  1236.     604   :DatabaseErrorMsg:='Unable To Access Sub Database (Out of Directory Stack)';
  1237.     605   :DatabaseErrorMsg:='Already At Highest Level (Already In Parent Database)';
  1238.     606   :DatabaseErrorMsg:='Data Size Mismatch';
  1239.     651..
  1240.     699   :DatabaseErrorMsg:='Compression System'+Temp+' Used.  Decompress File';
  1241.     701   :DatabaseErrorMsg:='Bad Database Signature (Not a Database File)';
  1242.     702   :DatabaseErrorMsg:='Unable to Read Database Signature (Not a Database File)';
  1243.     703   :DatabaseErrorMsg:='Cannot Have Segments Larger Than 64kb';
  1244.   End;
  1245. End;
  1246.  
  1247. End.
  1248.  
  1249. {
  1250. ╔══════════════════════════════════════════════════════════════╗
  1251. ║                   Pure Power Software                        ║
  1252. ╟──────────────────────────────────────────────────────────────╢
  1253. ║                                                              ║
  1254. ║       This  software  is copyright by Michael Gallias.       ║
  1255. ║                                                              ║
  1256. ╚══════════════════════════════════════════════════════════════╝
  1257. }
  1258.